home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir31 / gusutils.zip / GUSVOC.PAS < prev    next >
Pascal/Delphi Source File  |  1994-02-09  |  18KB  |  611 lines
  1. (****************************************************************************)
  2. (* Module     : GUSVOC.PAS                                                  *)
  3. (* Verion     : 0.6ß                                                        *)
  4. (* Date       : Thu Feb 3, 1994                                             *)
  5. (* Pascal     : TP 7.0                                                      *)
  6. (****************************************************************************)
  7. (*                                                                          *)
  8. (* NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE:                           *)
  9. (*                                                                          *)
  10. (* Copyright (C) 1993, 1994 by MESS Computer Services.                      *)
  11. (* Portions Copyright (C) 1993, 1994 by TBP Electronics Ltd.                *)
  12. (* All rights reserved.                                                     *)
  13. (*                                                                          *)
  14. (****************************************************************************)
  15. (* MESS Computer Services V.O.F.        MM   MM  EEEEEE   SSSSS   SSSSS     *)
  16. (* Jadestraat 54                        M M M M  E       S       S          *)
  17. (* 4817 JK  Breda                       M  M  M  EEEE     SSSS    SSSS      *)
  18. (* The Netherlands                      M     M  E            S       S     *)
  19. (*                                      M     M  EEEEEE  SSSSS   SSSSS      *)
  20. (* Tel: +31-76 22 34 31                                                     *)
  21. (* Fax: +31-76 20 46 23               Many Efforts for Structured Systems   *)
  22. (* Email: appel@stack.urc.tue.nl                                            *)
  23. (****************************************************************************)
  24.  
  25.  
  26. {$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  27. {$M 4096,0,0}
  28.  
  29. program GusVoc;
  30.  
  31. uses
  32.   Dos, Gus;
  33.  
  34. type
  35.   NameType  = array [1..8] of Char;
  36.  
  37.   GusSample = record
  38.     Id       : array[1..4] of Char;
  39.     Name     : NameType;
  40.     Start    : LongInt;
  41.     Stop     : LongInt;
  42.     Freq     : Word;
  43.     Bits     : Byte;
  44.     Chan     : Byte;
  45.     Reserved : array[1..8] of Byte;
  46.   end;
  47.  
  48. const
  49.   Hex : array [0..15] of Char = '0123456789ABCDEF';
  50.  
  51.   Empty : GusSample = (Id       : 'MESS';
  52.                        Name     : '        ';
  53.                        Start    : 0;
  54.                        Stop     : 0;
  55.                        Freq     : 0;
  56.                        Bits     : 0;
  57.                        Chan     : 0;
  58.                        Reserved : (0,0,0,0,0,0,0,0));
  59.  
  60.   InvalidVoc : String [20] = 'Error in .voc file: ';
  61.  
  62.   SampleBank = 32;
  63.  
  64. var
  65.   GusIndex  : array [1..SampleBank] of GusSample;
  66.   Available : LongInt;
  67.  
  68.   Handle    : File;
  69.   Buffer    : Array [1.. 40320] of Byte;
  70.   BufSize   : Word;
  71.   GusPtr    : LongInt;
  72.  
  73.   Path      : String;
  74.   Filename  : String;
  75.   Extension : String;
  76.  
  77.   Index     : Byte;
  78.  
  79.   Sounds    : Boolean;
  80.  
  81. function UpStr (St : String) : String;
  82. var
  83.   Loop : Byte;
  84. begin
  85.   UpStr[0] := St[0];
  86.   for Loop := 1 to Length(St)
  87.     do UpStr[Loop] := UpCase (St[Loop]);
  88. end;
  89.  
  90. function HexStr (L : LongInt) : String;
  91. var
  92.   St : String;
  93. begin
  94.   St := '00000';
  95.  
  96.   St[1] := Hex[L and $F0000 shr 16];
  97.   St[2] := Hex[L and $0F000 shr 12];
  98.   St[3] := Hex[L and $00F00 shr  8];
  99.   St[4] := Hex[L and $000F0 shr  4];
  100.   St[5] := Hex[L and $0000F shr  0];
  101.  
  102.   HexStr := St;
  103. end;
  104.  
  105. procedure Copyright;
  106. begin
  107.   WriteLn;
  108.   WriteLn ('Gravis Ultrasound Voice File Player      V0.6ß');
  109.   WriteLn ('(C)Copyright MESS Computer Services 1993, 1994');
  110.   WriteLn;
  111. end;
  112.  
  113. procedure InitGus;
  114. var
  115.   Index  : Byte;
  116.   Reload : Boolean;
  117. begin
  118.   (* GUS MEMORY AVAILABLE *)
  119.   Available := LongInt(GusMemory) * 1024 - 1;
  120.  
  121.   (* READ GUSINDEX *)
  122.   GusRead (0, GusIndex, SizeOf (GusIndex));
  123.  
  124.   (* TEST GUSINDEX *)
  125.   Reload := False;
  126.   Index := 1;
  127.   repeat
  128.     Reload := Reload or (GusIndex[Index].Id <> Empty.Id);
  129.     Inc (Index);
  130.   until (Reload or (Index > SampleBank));
  131.  
  132.   (* GUSINDEX NOT O.K. -> RESET GUS *)
  133.   if Reload then
  134.   begin
  135.     (* GUS INIT *)
  136.     GusInit (14);
  137.  
  138.     (* RESET & WRITE GUSINDEX *)
  139.     for Index := 1 to SampleBank do GusIndex[Index] := Empty;
  140.     GusWrite (0, GusIndex, SizeOf (GusIndex));
  141.  
  142.     (* OUTPUT ON *)
  143.     GusMixer (LineOut + LineIn);
  144.   end;
  145.  
  146.   (* PLAY ALL SOUNDS *)
  147.   Sounds := True;
  148. end;
  149.  
  150. procedure ShowIndex;
  151. var
  152.   Index  : Byte;
  153.   L1, L2 : Byte;
  154. begin
  155.   Copyright;
  156.  
  157.   if (GusBase = 0) then
  158.   begin
  159.     Write ('Error: ');
  160.     if MegaEm
  161.       then WriteLn ('Mega-Em is active.')
  162.       else WriteLn ('No Ultrasound card found.');
  163.     Halt (1);
  164.   end;
  165.  
  166.   WriteLn ('Nr  Name      Start   Stop    Freq   Bits        Time    Voices');
  167.   WriteLn ('--  --------  ------  ------  -----  ----------  ------  ------------');
  168.  
  169.   for Index := 1 to SampleBank do
  170.   begin
  171.     if (GusIndex[Index].Freq <> 0) then
  172.     begin
  173.       if Index = 17 then
  174.       begin
  175.         Write ('-- More --');
  176.         asm
  177.           push   ax
  178.           xor    ah, ah
  179.           int    16h
  180.           pop    ax
  181.         end;
  182.         WriteLn; WriteLn;
  183.       end;
  184.  
  185.       Write (Index:2, '  ', GusIndex[Index].Name:8, '  ',
  186.              HexStr(GusIndex[Index].Start), 'h  ', HexStr(GusIndex[Index].Stop), 'h  ',
  187.              GusIndex[Index].Freq:5, '  ', GusIndex[Index].Bits:2, ' ');
  188.  
  189.       case GusIndex[Index].Chan of
  190.         1 : Write ('Mono     ');
  191.         2 : Write ('Stereo   ');
  192.         else Write ('Multi-', GusIndex[Index].Chan, '  ');
  193.       end;
  194.  
  195.       Write  (((GusIndex[Index].Stop - GusIndex[Index].Start) shr
  196.               (GusIndex[Index].Bits shr 4) shr (GusIndex[Index].Chan shr 1) /
  197.               GusIndex[Index].Freq):5:1, 's  ');
  198.  
  199.       L2 := 0;
  200.       for L1 := 0 to GusVoices do
  201.       begin
  202.         if VoiceActive(L1) and (GetVoiceLoc (L1, LoopEnd) > GusIndex[Index].Start) and
  203.            (GetVoiceLoc (L1, LoopEnd) <= GusIndex[Index].Stop) then
  204.         begin
  205.           if (L2 >= 9) then
  206.           begin
  207.             if (L2 <= 12) then Write (Copy('....', 1, 13-L2));
  208.             L2 := 13;
  209.           end
  210.             else
  211.           begin
  212.             if (L2 > 0) then Write (',');
  213.             Write (L1+1);
  214.           end;
  215.           if (L1 >= 9) then Inc (L2, 3) else Inc (L2, 2);
  216.         end;
  217.       end;
  218.       WriteLn;
  219.     end;
  220.   end;
  221. end;
  222.  
  223. procedure ReadDataBlock(Size : LongInt);
  224. begin
  225.   while ((NOT EOF (Handle)) AND (Size > 0)) do
  226.   begin
  227.     if (SizeOf(Buffer) > Size)
  228.       then BlockRead (Handle, Buffer, Size, BufSize)
  229.       else BlockRead (Handle, Buffer, SizeOf(buffer), BufSize);
  230.  
  231.     if ((GusPtr + BufSize) >= Available) then
  232.     begin
  233.       Size := Size - BufSize;
  234.       BufSize := Available - GusPtr;
  235.     end;
  236.  
  237.     if (bufsize > 0) then GusWrite (GusPtr, Buffer, BufSize);
  238.  
  239.     GusPtr := GusPtr + BufSize;
  240.     Size   := Size - BufSize;
  241.   end;
  242. end;
  243.  
  244. function LoadFile (Index : Byte) : Boolean;
  245. var
  246.   St       : String;
  247.   Sort     : Byte;
  248.   Size     : LongInt;
  249.   DataType : Byte;
  250.   Loop     : Word;
  251. begin
  252.   (* FILENAME *)
  253.   LoadFile := False;
  254.   DataType := 0;
  255.   Size     := 0;
  256.   Filename := Filename + '.VOC';
  257.   if (GusIndex[Index].Start >= Available) then Exit;
  258.  
  259.   (* OPEN FILE *)
  260.   Assign (Handle, Path + Filename);
  261.   Reset (Handle, 1);
  262.  
  263.   if (IOResult = 0) then
  264.   begin
  265.     (* CHECK VOC HEADER *)
  266.     St[0] := Chr(19);
  267.     BlockRead (Handle, St[1], 19, BufSize);
  268.     if (St <> 'Creative Voice File') then
  269.     begin
  270.       WriteLn (InvalidVoc, Filename);
  271.       Exit;
  272.     end;
  273.  
  274.     (* CHECK VOC FORMAT *)
  275.     St[0] := Chr(255);
  276.     BlockRead (Handle, St[1], 6, BufSize);
  277.     if (St[1] <> Chr($1A)) then
  278.     begin
  279.       WriteLn (InvalidVoc, Filename);
  280.       Exit;
  281.     end;
  282.  
  283.     GusPtr := GusIndex[Index].Start;
  284.     Seek (Handle, Ord(St[2]) + (Ord(St[3]) shl 8));
  285.  
  286.     repeat
  287.       (* READ DATA BLOCK *)
  288.       BlockRead (Handle, Sort, 1, BufSize);
  289.       case sort of
  290.       0 : begin (* Terminator *)
  291.             (* GUSPTR = NEXT SAMPLE BYTE *)
  292.             GusIndex[Index].Stop := GusPtr -1;
  293.  
  294.             (* CLOSE FILE *)
  295.             Close (Handle);
  296.  
  297.             (* GUSDATA *)
  298.             GusDataConvert := False;
  299.             GusData16Bits  := False;
  300.  
  301.             (* LOADFILE := TRUE (O.K.) *)
  302.             LoadFile := True;
  303.           end;  (* Terminator *)
  304.  
  305.       1 : begin (* Sound Data *)
  306.  
  307.             BlockRead (Handle, Buffer, 5, BufSize);
  308.             Size := LongInt(Buffer[1]) + (LongInt(Buffer[2]) shl 8) + (LongInt(Buffer[3]) shl 16) -2;
  309.             DataType := Buffer[5];
  310.  
  311.             GusIndex[Index].Freq := Trunc(1000000 / (256 - Buffer[4]));
  312.             GusIndex[Index].Bits := 8;
  313.             GusIndex[Index].Chan := 1;
  314.  
  315.             GusDataConvert := True;
  316.             GusData16Bits  := False;
  317.  
  318.             if (DataType <> 0) then
  319.             begin
  320.               WriteLn('Compression Type other then 8bits not supported.');
  321.               exit;
  322.             end;
  323.  
  324.             ReadDataBlock(Size);
  325.  
  326.           end;  (* Sound Data *)
  327.  
  328.       2 : begin (* Sound Continue *)
  329.             BlockRead (Handle, Buffer, 3, BufSize);
  330.             Size := LongInt(Buffer[1]) + (LongInt(Buffer[2]) shl 8) + (LongInt(Buffer[3]) shl 16);
  331.  
  332.             GusDataConvert := True;
  333.             GusData16Bits  := False;
  334.  
  335.             ReadDataBlock(Size);
  336.  
  337.           end;  (* Sound Continue *)
  338.  
  339.       3 : begin (* Silence *)
  340.             BlockRead (Handle, Buffer, 6, BufSize);
  341.             Size := LongInt(Buffer[4]) + (LongInt(Buffer[5]) shl 8);
  342.  
  343.             for Loop := 1 to SizeOf(Buffer) do Buffer[Loop] := 0;
  344.  
  345.             GusDataConvert := True;
  346.             GusData16Bits  := False;
  347.  
  348.             while (Size > 0) do
  349.             begin
  350.  
  351.               BufSize := SizeOf(Buffer);
  352.               if ((GusPtr + BufSize) >= Available) then
  353.               begin
  354.                 BufSize := Available - GusPtr;
  355.               end;
  356.  
  357.               if (SizeOf(Buffer) > Size) then
  358.                 BufSize := Size;
  359.               GusWrite (GusPtr, Buffer, BufSize);
  360.  
  361.               GusPtr := GusPtr + BufSize;
  362.               Size   := Size - BufSize;
  363.             end;
  364.  
  365.           end;  (* Silence *)
  366.  
  367.       4 : begin (* Marker *)
  368.             BlockRead (Handle, Buffer, 5, BufSize);
  369.           end;  (* Marker *)
  370.  
  371.       5 : begin (* ASCII *)
  372.             BlockRead (Handle, Buffer, 3, BufSize);
  373.             Size := LongInt(Buffer[1]) + (LongInt(Buffer[2]) shl 8) + (LongInt(Buffer[3]) shl 16);
  374.  
  375.             (* TEXT *)
  376.             while ((NOT EOF (Handle)) AND (Size > 0)) do
  377.             begin
  378.               if (SizeOf(Buffer) > Size)
  379.                 then BlockRead (Handle, Buffer, Size, BufSize)
  380.                 else BlockRead (Handle, Buffer, SizeOf (Buffer), BufSize);
  381.             end;
  382.           end;  (* ASCII *)
  383.  
  384.       6 : begin (* Repeat *)
  385.             WriteLn('Repeat not (yet) supported');
  386.             exit;
  387.           end;  (* Repeat *)
  388.  
  389.       7 : begin (* End Repeat *)
  390.             WriteLn('Repeat not (yet) supported');
  391.             exit;
  392.           end;  (* End Repeat *)
  393.       else
  394.         begin
  395.           WriteLn('Invalid Block Type : ',Sort);
  396.           Exit;
  397.         end;
  398.       end; { Case }
  399.     until ((Sort = 0) OR (EOF(Handle)));
  400.  
  401.   end;
  402. end;
  403.  
  404. function FindFile (Name : String) : Byte; (* NAME = UPCASE *)
  405. var
  406.   Found  : Boolean;
  407.   Index  : Byte;
  408.   Loop   : Byte;
  409. begin
  410.   (* SEARCH NAME *)
  411.   Name := Copy (Name+'        ', 1, 8);
  412.   Index := 0;
  413.  
  414.   (* SEARCH *)
  415.   repeat
  416.     Inc (Index);
  417.     Found := True;
  418.     for Loop := 1 to 8
  419.       do Found := Found and (GusIndex[Index].Name[Loop] = Name[Loop]);
  420.   until (Found or (GusIndex[Index].Freq = 0) or (Index > SampleBank));
  421.  
  422.   (* NOT FOUND *)
  423.   if not Found and (Index <= SampleBank) then
  424.   begin
  425.     (* GUSINDEX.NAME *)
  426.     for Loop := 1 to 8
  427.       do GusIndex[Index].Name[Loop] := Name[Loop];
  428.     (* GUSINDEX.START *)
  429.     if (Index > 1)
  430.       then GusIndex[Index].Start := ((GusIndex[Index-1].Stop - 1) shr 5 + 1) shl 5
  431.       else GusIndex[Index].Start := SampleBank * SizeOf(GusSample);
  432.     (* WRITE GUSINDEX *)
  433.     if LoadFile (Index)
  434.       then GusWrite (0, GusIndex, SizeOf (GusIndex))
  435.       else Index := 0;
  436.   end;
  437.  
  438.   (* FINDFILE *)
  439.   if (Index > SampleBank) then Index := 0;
  440.   FindFile := Index;
  441. end;
  442.  
  443. procedure PlayFile (Nr : Byte);
  444. var
  445.   Voice : array [1..8] of Byte;
  446.   Index : Byte;
  447.   Len   : LongInt;
  448. begin
  449.   if Sounds then
  450.   begin
  451.     if ((Nr >= 1) and (Nr <= SampleBank)) then
  452.     begin
  453.       (* FREE VOICES *)
  454.       Voice[1] := 0;
  455.       for Index := 1 to GusIndex[Nr].Chan do
  456.       begin
  457.         while VoiceActive (Voice[Index]) and (Voice[Index] < GusVoices)
  458.           do Inc (Voice[Index]);
  459.         if (Index < GusIndex[Nr].Chan) then Voice[Index + 1] := Voice [Index] + 1;
  460.       end;
  461.  
  462.       for Index := 1 to GusIndex[Nr].Chan do
  463.       begin
  464.         if (Voice[Index] < GusVoices) then
  465.         begin
  466.           (* VOICE BALANCE *)
  467.           if GusIndex[Nr].Chan = 1 then VoiceBalance (Voice[Index], Middle)
  468.             else
  469.           begin
  470.             if Odd (Index)
  471.               then VoiceBalance (Voice[Index], Left)
  472.               else VoiceBalance (Voice[Index], Right);
  473.           end;
  474.  
  475.           (* VOICE VOLUME *)
  476.           VoiceVolume (Voice[Index], $000);
  477.  
  478.           (* VOICE MODE *)
  479.           if (GusIndex[Nr].Bits = 8)
  480.             then VoiceMode (Voice[Index], Bit8 + LoopOff + UniDir + Forw)
  481.             else VoiceMode (Voice[Index], Bit8 + LoopOff + UniDir + Forw);
  482.             (* SHOULD BE: BIT16 *)
  483.  
  484.           (* VOICE FREQ *)
  485.           VoiceFreq (Voice[Index], GusIndex[Nr].Freq shl (GusIndex[Nr].Bits shr 4));
  486.           (* BECAUSE: BITS8 *)
  487.  
  488.           (* VOICE SAMPLE *)
  489.           Len := (GusIndex[Nr].Stop - GusIndex[Nr].Start) div GusIndex[Nr].Chan;
  490.           VoiceSample (Voice[Index],
  491.                        GusIndex[Nr].Start + (Index - 1) * Len,
  492.                        GusIndex[Nr].Start + (Index - 1) * Len,
  493.                        GusIndex[Nr].Start  + Index * Len);
  494.  
  495.           (* VOICE RAMP *)
  496.           RampRate (Voice[Index], 0, 34);
  497.           RampRange (Voice[Index], $000, $F00);
  498.           RampMode (Voice[Index], LoopOff+UniDir+Up);
  499.         end;
  500.       end;
  501.  
  502.       for Index := 1 to GusIndex[Nr].Chan do
  503.       begin
  504.         if (Voice[Index] < GusVoices) then
  505.         begin
  506.           VoiceStart (Voice[Index]);
  507.           RampStart (Voice[Index]);
  508.         end;
  509.       end;
  510.     end;
  511.   end;
  512. end;
  513.  
  514. begin
  515.   InitGus;
  516.  
  517.   (* ANTI-VOLUME-CLIPPING *)
  518.   for Index := 0 to GusVoices - 1 do
  519.     if not VoiceActive (Index) then VoiceInit (Index);
  520.  
  521.   (* INDEX *)
  522.   if (ParamCount = 0) then ShowIndex
  523.     else
  524.  
  525.   for Index := 1 to ParamCount do
  526.   begin
  527.     (* FILENAME OR PARAMETER *)
  528.     FSplit (UpStr(ParamStr(Index)), Path, Filename, Extension);
  529.     if (Filename[1] = '/') or (Filename[1] = '-')
  530.     then Delete (Filename, 1, 1);
  531.  
  532.     (* INDEX *)
  533.     if (Filename = 'INDEX') or (Filename = 'X') then
  534.     begin
  535.       ShowIndex;
  536.     end else begin
  537.  
  538.     (* SILENCE *)
  539.     if (Filename = 'LOAD') or (Filename = 'L') then
  540.     begin
  541.       Sounds := False;
  542.     end else begin
  543.  
  544.     (* SOUND ON *)
  545.     if (Filename = 'PLAY') or (Filename = 'P') then
  546.     begin
  547.       Sounds := True;
  548.     end else begin
  549.  
  550.     (* INIT *)
  551.     if (Filename = 'INIT') or (Filename = 'I') then
  552.     begin
  553.       (* INIT GUS *)
  554.       GusInit (14);
  555.  
  556.       (* OUTPUT ON *)
  557.       GusMixer (LineOut + LineIn);
  558.  
  559.       (* SOUNDS ON *)
  560.       Sounds := True;
  561.     end else begin
  562.  
  563.     (* CLEAR *)
  564.     if (Filename = 'CLEAR') or (Filename = 'C') then
  565.     begin
  566.       (* STOP VOICES *)
  567.       for BufSize := 0 to GusVoices - 1 do VoiceInit (BufSize);
  568.       (* RESET INDEX *)
  569.       for BufSize := 1 to SampleBank do GusIndex[BufSize] := Empty;
  570.       GusWrite (0, GusIndex, SizeOf (GusIndex));
  571.     end else begin
  572.  
  573.     (* HELP *)
  574.     if (Filename = 'HELP') or (Filename = '?') then
  575.     begin
  576.       Copyright;
  577.       WriteLn ('Usage : GUSVOC [options] [switches] [drive:][path][filename] [#no]');
  578.       WriteLn;
  579.       WriteLn ('Options   Short  Explanation');
  580.       WriteLn ('--------  -----  -------------------------------------------------------');
  581.       WriteLn (' Stop      -S     Stop all samples from playing.');
  582.       WriteLn (' Init      -I     Initialize the Ultrasound but leave samples in memory.');
  583.       WriteLn (' Clear     -C     Clear all samples from the Ultrasound memory.');
  584.       WriteLn (' Index     -X     Show the samples in the Ultrasound memory (default).');
  585.       WriteLn (' Help      -?     Shows this help text.');
  586.       WriteLn;
  587.       WriteLn ('Switches  Short  Explanation');
  588.       WriteLn ('--------  -----  -------------------------------------------------------');
  589.       WriteLn (' Load      -L     Just load samples, don''t play.');
  590.       WriteLn (' Play      -P     Load and play samples (default).');
  591.     end else begin
  592.  
  593.     (* STOP *)
  594.     if (Filename = 'STOP') or (Filename = 'S')  then
  595.     begin
  596.       (* STOP VOICES *)
  597.       for BufSize := 0 to GusVoices - 1 do VoiceInit (BufSize);
  598.     end else
  599.  
  600.     (* NUMBER OR FILENAME *)
  601.     begin
  602.       Val (Filename, BufSize, BufSize);
  603.       if (BufSize < 1) or (BufSize > SampleBank) then PlayFile (FindFile (Filename))
  604.         else if (GusIndex[BufSize].Freq <> 0) then PlayFile (BufSize);
  605.     end; end; end; end; end; end; end; end;
  606.  
  607.   (* ANTI-VOLUME-CLIPPING *)
  608.   for Index := 0 to GusVoices - 1 do
  609.     if not VoiceActive (Index) then VoiceInit (Index);
  610. end.
  611.